home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xlsubr.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  4KB  |  187 lines
  1. /* xlsubr - xlisp builtin function support routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL k_test,k_tnot,s_eql;
  10.  
  11. /* xlsubr - define a builtin function */
  12. LVAL xlsubr(sname,type,fcn,offset)
  13.   char *sname; int type; LVAL (*fcn)(); int offset;
  14. {
  15.     LVAL sym;
  16.     sym = xlenter(sname);
  17.     setfunction(sym,cvsubr(fcn,type,offset));
  18.     return (sym);
  19. }
  20.  
  21. /* xlgetkeyarg - get a keyword argument */
  22. int xlgetkeyarg(key,pval)
  23.   LVAL key,*pval;
  24. {
  25.     LVAL *argv=xlargv;
  26.     int argc=xlargc;
  27.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  28.     if (*argv == key) {
  29.         *pval = *++argv;
  30.         return (TRUE);
  31.     }
  32.     }
  33.     return (FALSE);
  34. }
  35.  
  36. /* xlgkfixnum - get a fixnum keyword argument */
  37. int xlgkfixnum(key,pval)
  38.   LVAL key,*pval;
  39. {
  40.     if (xlgetkeyarg(key,pval)) {
  41.     if (!fixp(*pval))
  42.         xlbadtype(*pval);
  43.     return (TRUE);
  44.     }
  45.     return (FALSE);
  46. }
  47.  
  48. /* xltest - get the :test or :test-not keyword argument */
  49. xltest(pfcn,ptresult)
  50.   LVAL *pfcn; int *ptresult;
  51. {
  52.     if (xlgetkeyarg(k_test,pfcn))    /* :test */
  53.     *ptresult = TRUE;
  54.     else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
  55.     *ptresult = FALSE;
  56.     else {
  57.     *pfcn = getfunction(s_eql);
  58.     *ptresult = TRUE;
  59.     }
  60. }
  61.  
  62. /* xlgetfile - get a file or stream */
  63. LVAL xlgetfile()
  64. {
  65.     LVAL arg;
  66.  
  67.     /* get a file or stream (cons) or nil */
  68.     if (arg = xlgetarg()) {
  69.     if (streamp(arg)) {
  70.         if (getfile(arg) == NULL)
  71.         xlfail("file not open");
  72.     }
  73.     else if (!ustreamp(arg))
  74.         xlerror("bad argument type",arg);
  75.     }
  76.     return (arg);
  77. }
  78.  
  79. /* xlgetfname - get a filename */
  80. LVAL xlgetfname()
  81. {
  82.     LVAL name;
  83.  
  84.     /* get the next argument */
  85.     name = xlgetarg();
  86.  
  87.     /* get the filename string */
  88.     if (symbolp(name))
  89.     name = getpname(name);
  90.     else if (!stringp(name))
  91.     xlerror("bad argument type",name);
  92.  
  93.     /* return the name */
  94.     return (name);
  95. }
  96.  
  97. /* needsextension - check if a filename needs an extension */
  98. int needsextension(name)
  99.   char *name;
  100. {
  101.     char *p;
  102.  
  103.     /* check for an extension */
  104.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  105.     if (*p == '.')
  106.         return (FALSE);
  107.     else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  108.         return (TRUE);
  109.  
  110.     /* no extension found */
  111.     return (TRUE);
  112. }
  113.  
  114. /* xlbadtype - report a "bad argument type" error */
  115. LVAL xlbadtype(arg)
  116.   LVAL arg;
  117. {
  118.     xlerror("bad argument type",arg);
  119. }
  120.  
  121. /* xltoofew - report a "too few arguments" error */
  122. LVAL xltoofew()
  123. {
  124.     xlfail("too few arguments");
  125. }
  126.  
  127. /* xltoomany - report a "too many arguments" error */
  128. xltoomany()
  129. {
  130.     xlfail("too many arguments");
  131. }
  132.  
  133. /* eq - internal eq function */
  134. int eq(arg1,arg2)
  135.   LVAL arg1,arg2;
  136. {
  137.     return (arg1 == arg2);
  138. }
  139.  
  140. /* eql - internal eql function */
  141. int eql(arg1,arg2)
  142.   LVAL arg1,arg2;
  143. {
  144.     /* compare the arguments */
  145.     if (arg1 == arg2)
  146.     return (TRUE);
  147.     else if (arg1) {
  148.     switch (ntype(arg1)) {
  149.     case FIXNUM:
  150.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  151.     case FLONUM:
  152.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  153.     default:
  154.         return (FALSE);
  155.     }
  156.     }
  157.     else
  158.     return (FALSE);
  159. }
  160.  
  161. /* equal - internal equal function */
  162. int equal(arg1,arg2)
  163.   LVAL arg1,arg2;
  164. {
  165.     /* compare the arguments */
  166.     if (arg1 == arg2)
  167.     return (TRUE);
  168.     else if (arg1) {
  169.     switch (ntype(arg1)) {
  170.     case FIXNUM:
  171.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  172.     case FLONUM:
  173.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  174.     case STRING:
  175.         return (stringp(arg2) ? strcmp(getstring(arg1),
  176.                        getstring(arg2)) == 0 : FALSE);
  177.     case CONS:
  178.         return (consp(arg2) ? equal(car(arg1),car(arg2))
  179.                    && equal(cdr(arg1),cdr(arg2)) : FALSE);
  180.     default:
  181.         return (FALSE);
  182.     }
  183.     }
  184.     else
  185.     return (FALSE);
  186. }
  187.